home *** CD-ROM | disk | FTP | other *** search
- /* Scheme In One Define.
-
- The garbage collector, the name and other parts of this program are
-
- * COPYRIGHT (c) 1989 BY *
- * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
-
- Conversion to full scheme standard, characters, vectors, ports, complex &
- rational numbers, and other major enhancments by
-
- * Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY *
-
- Permission to use, copy, modify, distribute and sell this software and its
- documentation for any purpose and without fee is hereby granted, provided
- that the above copyright notice appear in all copies and that both that
- copyright notice and this permission notice appear in supporting
- documentation, and that the name of Paradigm Associates Inc not be used in
- advertising or publicity pertaining to distribution of the software without
- specific, written prior permission.
-
- PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
- ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
- PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
- ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
- IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
- OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-
- */
-
- #include <stdio.h>
- #include <string.h>
- #include <ctype.h>
- #include <setjmp.h>
- #include <signal.h>
- #include <math.h>
-
- #include "siod.h"
-
- LISP lquotient(LISP x,LISP y)
- {LISP z;
- double res;
- x = tofloat(x);
- y = tofloat(y);
- if (NFLONUMP(x)||(modf(FLONM(x),&res)!=0.))
- err("quotient",x,ERR_FIRST | ERR_NINT);
- if (NFLONUMP(y)||(modf(FLONM(y),&res)!=0.))
- err("quotient",y,ERR_SECOND | ERR_NINT);
- modf(FLONM(x)/FLONM(y),&res);
- z = flocons(res);
- return(z);}
-
- LISP lmax(LISP args)
- {LISP l,s;
- LISP res;
- s = car(args);
- if(NNUMBERP(s))
- err("max",s,ERR_FIRST | ERR_NNUM);
- res=s;
- args=cdr(args);
- for(l=args;NNULLP(l);l=cdr(l))
- {s = car(l);
- if (NNUMBERP(s))
- err("max",s,ERR_GEN_ARG | ERR_NNUM);
- res=EQ(truth,greaterp(res,s)) ? res : s;}
- return(res);}
-
- LISP lmin(LISP args)
- {LISP l,s;
- LISP res;
- s = car(args);
- if(NNUMBERP(s))
- err("min",s,ERR_FIRST | ERR_NNUM);
- res=s;
- args=cdr(args);
- for(l=args;NNULLP(l);l=cdr(l))
- {s = car(l);
- if (NNUMBERP(s))
- err("min",s,ERR_GEN_ARG | ERR_NNUM);
- res=EQ(truth,lessp(res,s)) ? res : s;}
- return(res);}
-
- double cal_gcd_double(double a,double b)
- {double tmp;
- while(b!=0.)
- {tmp=b;
- b=fmod(a,b);
- a=tmp;}
- return(fabs(a));}
-
- LISP gcd(LISP args)
- {LISP l,s,z;
- double res,tmp;
- res=0.;
- for(l=args;NNULLP(l);l=cdr(l))
- {s = car(l);
- s = tofloat(s);
- if (NFLONUMP(s)||(modf(FLONM(s),&tmp)!=0.))
- err("gcd",s,ERR_GEN_ARG | ERR_NINT);
- res=cal_gcd_double(FLONM(s),res);}
- z = flocons(res);
- return(z);}
-
- LISP lcm(LISP args)
- {LISP l,s,z;
- double res,gcd,tmp;
- res=1;
- for(l=args;NNULLP(l);l=cdr(l))
- {s = car(l);
- s = tofloat(s);
- if (NFLONUMP(s)||(modf(FLONM(s),&tmp)!=0.))
- err("lcm",s,ERR_GEN_ARG | ERR_NINT);
- tmp = FLONM(s);
- gcd = cal_gcd_double(tmp,res);
- res = (tmp * res) / gcd;}
- z = flocons(res);
- return(z);}
-
- LISP lround(LISP x)
- {LISP z;
- double tmp,tmp2;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = intcons(INTNM(x));
- break;
- case tc_ratnum:
- tmp = (double)RATNUM(x)/(double)RATDEN(x);
- z = intcons((long)ceil((tmp-.5)));
- break;
- case tc_flonum:
- tmp = FLONM(x);
- z = flocons(ceil((tmp-.5)));
- break;
- case tc_compnum:
- tmp = (double)COMPRE(x);
- tmp2 = (double)COMPIM(x);
- z = compcons((float)ceil((tmp-.5)),
- (float)ceil((tmp2-.5)));
- break;
- default:
- err("round",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP ltruncate(LISP x)
- {LISP z;
- double re,im;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = intcons(INTNM(x));
- break;
- case tc_ratnum:
- z = intcons(RATNUM(x)/RATDEN(x));
- break;
- case tc_flonum:
- modf(FLONM(x),&re);
- z = flocons(re);
- break;
- case tc_compnum:
- modf((double)COMPRE(x),&re);
- modf((double)COMPIM(x),&im);
- z = compcons((float)re,(float)im);
- break;}
- return(z);}
-
- LISP lltruncate(LISP x)
- {if(NNUMBERP(x))
- err("truncate",x,ERR_GEN_ARG | ERR_NNUM);
- return(ltruncate(x));}
-
- LISP lfloor(LISP x)
- {LISP z;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = intcons(INTNM(x));
- break;
- case tc_ratnum:
- z = flocons(floor((double)RATNUM(x)/(double)RATDEN(x)));
- break;
- case tc_flonum:
- z = flocons(floor(FLONM(x)));
- break;
- case tc_compnum:
- z = compcons((float)floor((double)COMPRE(x)),
- (float)floor((double)COMPIM(x)));
- break;
- default:
- err("floor",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP ceiling(LISP x)
- {LISP z;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = intcons(INTNM(x));
- break;
- case tc_ratnum:
- z = flocons(ceil((double)RATNUM(x)/(double)RATDEN(x)));
- break;
- case tc_flonum:
- z = flocons(ceil(FLONM(x)));
- break;
- case tc_compnum:
- z = compcons((float)ceil((double)COMPRE(x)),
- (float)ceil((double)COMPIM(x)));
- break;
- default:
- err("ceiling",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP lsqrt(LISP x)
- {LISP z;
- double tmp1,tmp2;
- switch(TYPE(x))
- {
- case tc_intnum:
- tmp1 = (double)INTNM(x);
- if(tmp1>=0.)
- z = flocons(sqrt(tmp1));
- else
- z = compcons((float)0,(float)sqrt(-tmp1));
- break;
- case tc_ratnum:
- tmp1 = (double)RATNUM(x);
- tmp2 = (double)RATDEN(x);
- if(tmp1>=0.)
- z = ratcons(sqrt(tmp1),sqrt(tmp2));
- else
- z = compcons((float)0,(float)sqrt(-tmp1/tmp2));
- break;
- case tc_flonum:
- tmp1 = (double)FLONM(x);
- if(tmp1>=0.)
- z = flocons(sqrt(tmp1));
- else
- z = compcons((float)0,(float)sqrt(-tmp1));
- break;
- case tc_compnum:
- tmp1 = (((double)COMPRE(x)*
- (double)COMPRE(x))+
- ((double)COMPIM(x)*
- (double)COMPIM(x)));
- tmp2 = atan2((double)COMPRE(x),(double)COMPIM(x))/2;
- z = compcons((float)(tmp1*cos(tmp2)),(float)(tmp1*sin(tmp2)));
- break;
- default:
- err("sqrt",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP lexp(LISP x)
- {LISP z;
- x=tofloat(x);
- if NFLONUMP(x) err("exp",x,ERR_GEN_ARG | ERR_NNUM);
- z = flocons(exp(FLONM(x)));
- return(z);}
-
- LISP llog(LISP x,LISP y)
- {LISP z;
- x=tofloat(x);
- y=tofloat(y);
- if NFLONUMP(x) err("log",x,ERR_FIRST | ERR_NNUM);
- if (NFLONUMP(x)&&NNULLP(x)) err("log",y,ERR_SECOND | ERR_NNUM);
- if(NULLP(y))
- z = flocons(log(FLONM(x)));
- else
- z = flocons(log(FLONM(x))/log(FLONM(y)));
- return(z);}
-
- LISP lsin(LISP x)
- {LISP z;
- x=tofloat(x);
- if NFLONUMP(x) err("sin",x,ERR_GEN_ARG | ERR_NNUM);
- z = flocons(sin(FLONM(x)));
- return(z);}
-
- LISP lcos(LISP x)
- {LISP z;
- x=tofloat(x);
- if NFLONUMP(x) err("cos",x,ERR_GEN_ARG | ERR_NNUM);
- z = flocons(cos(FLONM(x)));
- return(z);}
-
- LISP ltan(LISP x)
- {LISP z;
- x=tofloat(x);
- if NFLONUMP(x) err("tan",x,ERR_GEN_ARG | ERR_NNUM);
- z = flocons(tan(FLONM(x)));
- return(z);}
-
- LISP lasin(LISP x)
- {LISP z;
- x=tofloat(x);
- if NFLONUMP(x) err("asin",x,ERR_GEN_ARG | ERR_NNUM);
- z = flocons(asin(FLONM(x)));
- return(z);}
-
- LISP lacos(LISP x)
- {LISP z;
- x=tofloat(x);
- if NFLONUMP(x) err("acos",x,ERR_GEN_ARG | ERR_NNUM);
- z = flocons(acos(FLONM(x)));
- return(z);}
-
- LISP latan(LISP x,LISP y)
- {LISP z;
- x=tofloat(x);
- y=tofloat(y);
- if NFLONUMP(x) err("atan",x,ERR_FIRST | ERR_NNUM);
- if (NFLONUMP(y)&&NNULLP(y)) err("atan",y,ERR_SECOND | ERR_NNUM);
- if(NULLP(y))
- z = flocons(atan(FLONM(x)));
- else
- z = flocons(atan2(FLONM(x),FLONM(y)));
- return(z);}
-
- LISP add1(LISP x)
- {LISP z;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = flocons((double)INTNM(x)+1);
- break;
- case tc_ratnum:
- z = ratcons((double)RATNUM(x)+(double)RATDEN(x),(double)RATDEN(x));
- break;
- case tc_flonum:
- z = flocons(FLONM(x)+1.);
- break;
- case tc_compnum:
- z = compcons((float)(COMPRE(x)+1.),COMPIM(x));
- break;
- default:
- err("add1",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP sub1(LISP x)
- {LISP z;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = flocons((double)INTNM(x)-1);
- break;
- case tc_ratnum:
- z = ratcons((double)RATNUM(x)-(double)RATDEN(x),(double)RATDEN(x));
- break;
- case tc_flonum:
- z = flocons(FLONM(x)-1.);
- break;
- case tc_compnum:
- z = compcons((float)(COMPRE(x)-1.),COMPIM(x));
- break;
- default:
- err("sub1",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP minus(LISP x)
- {LISP z;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = intcons(-INTNM(x));
- break;
- case tc_ratnum:
- z = ratco(-RATNUM(x),RATDEN(x));
- break;
- case tc_flonum:
- z = flocons(-FLONM(x));
- break;
- case tc_compnum:
- z = compcons((float)(-COMPRE(x)),(float)(-COMPIM(x)));
- break;
- default:
- err("minus",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
- LISP Labs(LISP x)
- {LISP z;
- switch(TYPE(x))
- {
- case tc_intnum:
- z = intcons(abs(INTNM(x)));
- break;
- case tc_ratnum:
- z = ratco(abs(RATNUM(x)),
- RATDEN(x));
- break;
- case tc_flonum:
- z = flocons(fabs(FLONM(x)));
- break;
- case tc_compnum:
- z = flocons(sqrt((COMPRE(x)*COMPRE(x))+(COMPIM(x)*COMPIM(x))));
- break;
- default:
- err("abs",x,ERR_GEN_ARG | ERR_NNUM);}
- return(z);}
-
-